COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	letby.lsp[f82,jmc]	Call-by-need let macro
C00005 00003	 new start on let-by-need
C00007 ENDMK
C⊗;
letby.lsp[f82,jmc]	Call-by-need let macro

(defmacro let-by-need ((var exp) body) (letify var exp body))

(defun letify (var exp body)
       (cond ((absent var body) body)
	     ((atom body) (if (eq body var) exp body))
	     ((inevitable var body) `(let ((,var ,exp)) ,body))
	     ((eq (car body) 'if) (lbn1 (cadr body)
					(caddr body)
					(caddr body)
					var
					exp))



(defun lbn1 (prop conseq altern var exp)
       (cond ((absent var prop) `(if ,prop
				     ,(letify var exp conseq)
				     ,(letify var exp altern)))
	     ((and (absent var conseq) (absent var altern))
	      `(if ,prop ,(letify var exp conseq) ,(letify var exp altern)))
	     (t (letify var exp (evert `(if ,prop ,conseq ,altern) var)))))

(defun evert (exp var) (cond ((or (inevitable var exp) (absent var exp)) exp)

(defun inevitable (var exp)
       (cond ((atom exp) (eq var exp))
	     ((eq (car exp) 'if) (or (inevitable var (cadr exp))
				     (and (inevitable var (caddr exp))
					  (inevitable var (caddr exp)))))
	     ((or (eq (car exp) 'and) (eq (car exp) 'or))
	      (and (not (null (cdr exp))) (inevitable var (cadr exp))))
	     ((eq (car exp) 'cond) (inevcond var (cdr exp)))


(defun inevcond (var u)
       (and (not (null u))
	    (or (inevitable var (caar u))
		(and (inevlist var (cdar u))
		     (inevcond var (cdr u))))))

(defun inevlist (var u) (and (not (null u))
			     (or (inevitable var (car u))
				 (inevlist var (cdr u)))))
; new start on let-by-need

(defun letify1 (exp var)
       (cond
	((atom exp) (if (eq exp var) (cons exp 'inev) (values exp 'abs)))
	(t (multiple-value-bind
	    (p p1)
	    (letify1 (prop exp) vars)
	    (multiple-value-bind
	     (a a1)
	     (letify1 (conseq exp) vars)
	     (multiple-value-bind
	      (b b1)
	      (letify1 (altern exp) vars)
	      (cond ((or (eq p1 'inev) (and (eq a1 'inev) (eq b1 'inev)))
		     (values exp 'inev))
		    ((and (eq a1 'abs) (eq b1 'abs))
		     (values exp 'abs))
		    (t
		     (values (mkif1 exp p a a1 b b1) 'maybe)))))))))

(defun letify (exp var exp1)
       (multiple-value-bind
	(e e1)
	(letify1 exp var) (letify2 e e1 var exp1)))

(defun letify2 (exp flag var exp1)
       (cond ((eq flag 'abs)
	      exp)
	     ((eq flag 'inev)
	      (letify3